;; private.scm: private definitions and support API for r6rs-thrift
;; Copyright (C) 2012 Julian Graham

;; r6rs-thrift is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

#!r6rs

(library (thrift private)
  (export thrift:condition?
  
          thrift:make-field-type-descriptor
	  thrift:field-type-descriptor-default
	  thrift:field-type-descriptor-name
	  thrift:field-type-descriptor-location
	  thrift:field-type-descriptor-predicate
	  thrift:field-type-descriptor-wire-type

	  thrift:make-type-reference
	  thrift:type-reference?
	  thrift:type-reference-name
	  thrift:type-reference-descriptor
	  thrift:type-reference-location
	  thrift:set-type-reference-descriptor!

	  thrift:make-complex-type-reference
	  thrift:complex-type-reference?
	  thrift:complex-type-reference-parameters

	  thrift:make-parameterized-field-type-descriptor
	  thrift:parameterized-field-type-descriptor
	  thrift:parameterized-field-type-descriptor?
	  thrift:parameterized-field-type-descriptor-parameters

	  thrift:make-enum-field-type-descriptor
	  thrift:enum-field-type-descriptor?
	  thrift:enum-field-type-descriptor-values

	  thrift:enum-value-descriptor
	  thrift:enum-value-descriptor?
	  thrift:make-enum-value-descriptor
	  thrift:enum-value-descriptor-name
	  thrift:enum-value-descriptor-ordinal
	  
	  thrift:make-struct-field-type-descriptor
	  thrift:struct-field-type-descriptor?
	  thrift:struct-field-type-descriptor-record-type
	  thrift:struct-field-type-descriptor-exception?
	  thrift:struct-field-type-descriptor-fields
	  thrift:struct-field-type-descriptor-union?

	  thrift:make-function-descriptor
	  thrift:function-descriptor?

	  thrift:make-service-descriptor
	  thrift:service-descriptor?
	  thrift:service-descriptor-name
	  thrift:service-descriptor-location
	  thrift:service-descriptor-parent
	  thrift:service-descriptor-functions

	  thrift:wire-type
	  thrift:wire-types

          thrift:field-type-void
          thrift:field-type-double
	  thrift:field-type-i16
	  thrift:field-type-i32
	  thrift:field-type-i64
	  thrift:field-type-bool
	  thrift:field-type-byte
	  thrift:field-type-string
	  thrift:field-type-binary
	  thrift:field-type-struct
	  thrift:field-type-enum
	  thrift:field-type-union

	  thrift:field-type-list-prototype
	  thrift:field-type-map-prototype
	  thrift:field-type-set-prototype
	  
	  thrift:make-field-descriptor
	  thrift:field-descriptor-default
	  thrift:field-descriptor-index
	  thrift:field-descriptor-name
	  thrift:field-descriptor-type

	  thrift:function-descriptor-name
	  thrift:function-descriptor-return-type
	  thrift:function-descriptor-arguments

	  thrift:make-field
	  thrift:field-field-descriptor
	  thrift:field-value
	  thrift:field-has-value?
	  thrift:set-field-value!
	  thrift:clear-field!

	  thrift:struct
	  thrift:make-struct
	  thrift:struct-descriptor
	  thrift:struct-field
	  thrift:struct-fields
	  thrift:struct-write
	  thrift:struct-read
	  
	  thrift:struct-builder
	  thrift:struct-builder?
	  thrift:make-struct-builder
	  thrift:struct-builder-field
	  thrift:struct-builder-fields	  
	  thrift:struct-builder-build
	  
	  &thrift:exception
	  thrift:exception?
	  thrift:make-exception
	  thrift:exception-descriptor
	  thrift:exception-fields

	  thrift:message-type
	  thrift:message-types

	  thrift:make-message
	  thrift:message?
	  thrift:message-name
	  thrift:message-type-symbol
	  thrift:message-seq-id

	  thrift:make-sequence
	  thrift:sequence?
	  thrift:sequence-value
	  thrift:increment-sequence!

	  thrift:client
	  thrift:client?
	  thrift:client-transport
	  thrift:client-protocol
	  thrift:client-sequence
	  thrift:client-functions

	  thrift:type->equivalence-function
	  thrift:type->hash-function
	  
	  thrift:register-service!
	  thrift:resolve-service
	  thrift:register-type!
	  thrift:resolve-type)

  (import (rnrs)
	  (srfi :1))

  (define-condition-type &thrift:condition &condition thrift:make-condition
    thrift:condition?)

  (define-enumeration
    thrift:message-type (call reply exception oneway) thrift:message-types)
  
  (define-record-type (thrift:type-reference
		       thrift:make-type-reference
		       thrift:type-reference?)
    (fields name
	    (mutable location
		     thrift:type-reference-location
		     thrift:set-type-reference-location!)
	    (mutable descriptor
		     thrift:type-reference-descriptor
		     thrift:set-type-reference-descriptor!)))

  (define-record-type (thrift:complex-type-reference
		       thrift:make-complex-type-reference
		       thrift:complex-type-reference?)
    (fields parameters)
    (parent thrift:type-reference)
    (protocol (lambda (n)
		(lambda (name location descriptor . parameters)
		  (let ((p (n name location descriptor)))
		    (p parameters))))))

  (define-record-type (thrift:message thrift:make-message thrift:message?)
    (fields name type-symbol seq-id)
    (sealed #t))

  (define-record-type (thrift:sequence thrift:make-sequence thrift:sequence?)
    (fields (mutable value thrift:sequence-value thrift:set-sequence-value!))
    (protocol (lambda (p) (lambda () (p 0))))
    (sealed #t))

  (define (thrift:increment-sequence! sequence)
    (thrift:set-sequence-value! 
     sequence (+ (thrift:sequence-value sequence) 1)))

  (define-record-type (thrift:client thrift:make-client thrift:client?)
    (fields transport protocol sequence descriptor))

  (define-enumeration
    thrift:wire-type
    (stop void bool byte double i16 i32 i64 string struct map set list enum)
    thrift:wire-types)

  (define-record-type (thrift:field-type-descriptor
		       thrift:make-field-type-descriptor
		       thrift:field-type-descriptor?)
    (fields name
	    location
	    wire-type 
	    predicate 
	    hash-function 
	    equivalence-function 
	    default))

  (define-record-type (thrift:parameterized-field-type-descriptor
		       thrift:make-parameterized-field-type-descriptor
		       thrift:parameterized-field-type-descriptor?)
    (parent thrift:field-type-descriptor)
    (fields parameters))

  (define-record-type (thrift:enum-field-type-descriptor
		       thrift:make-enum-field-type-descriptor
		       thrift:enum-field-type-descriptor?)
    (parent thrift:field-type-descriptor)
    (protocol
     (lambda (n)
       (lambda (name location default values)
	 (let ((p (n name location (thrift:wire-type enum)
		     (make-enum-predicate values)
		     symbol-hash eq? default)))
	   (p values)))))
    (fields values))

  (define-record-type (thrift:enum-value-descriptor
		       thrift:make-enum-value-descriptor
		       thrift:enum-value-descriptor?)
    (fields name ordinal))

  (define-record-type (thrift:struct-field-type-descriptor
		       thrift:make-struct-field-type-descriptor
		       thrift:struct-field-type-descriptor?)
    (fields record-type fields exception? union?)
    (parent thrift:field-type-descriptor)
    (protocol
     (lambda (n)
       (lambda (name location record-type fields exception? union?)	 
	 (let* ((predicate
		 (if exception?
		     (make-exception-predicate name fields)
		     (make-struct-predicate name fields)))
		(p (n name location (thrift:wire-type struct) predicate 
		      struct-hash struct-equal? #f)))
	   (p record-type fields exception? union?))))))

  (define-record-type (thrift:field-descriptor
		       thrift:make-field-descriptor
		       thrift:field-descriptor?)
    (fields index name type required? default)) 

  (define-record-type (thrift:field thrift:make-field thrift:field?)
    (fields
     (mutable value thrift:field-value thrift:set-field-value-internal!)
     (immutable descriptor thrift:field-field-descriptor)
     (mutable has-value? 
	      thrift:field-has-value? 
	      thrift:set-field-has-value!))
    (protocol 
     (lambda (p)
       (lambda (descriptor . value)
	 (if (null? value)
	     (p (thrift:field-descriptor-default descriptor) descriptor #f)
	     (p (car value) descriptor #t))))))

  (define-record-type (thrift:struct thrift:make-struct thrift:struct?)
    (fields descriptor fields))

  (define-record-type (thrift:struct-builder 
		       thrift:make-struct-builder
		       thrift:struct-builder?)
    (fields type-descriptor fields)
    (protocol
     (lambda (p)
       (lambda (type-reference)
	 (let* ((type-descriptor (thrift:resolve-type type-reference)))
	   (p type-descriptor 
	      (map thrift:make-field
		   (thrift:struct-field-type-descriptor-fields 
		    type-descriptor))))))))

  (define-record-type (thrift:function-descriptor
		       thrift:make-function-descriptor
		       thrift:function-descriptor?)
    (fields name return-type arguments throws oneway?))

  (define-record-type (thrift:service-descriptor
		       thrift:make-service-descriptor
		       thrift:service-descriptor?)
    (fields name location parent functions))

  (define (type-reference-hash tr)
    (string-hash 
     (string-append 
      (thrift:type-reference-location tr) (thrift:type-reference-name tr))))

  (define (type-reference-equiv? tr1 tr2)
    (and (equal? (thrift:type-reference-location tr1)
		 (thrift:type-reference-location tr2))
	 (equal? (thrift:type-reference-name tr1)
		 (thrift:type-reference-name tr2))))

  (define types (make-hashtable type-reference-hash type-reference-equiv?))

  (define (thrift:register-type! type-descriptor)
    (hashtable-set! 
     types 
     (thrift:make-type-reference 
      (thrift:field-type-descriptor-name type-descriptor)
      (thrift:field-type-descriptor-location type-descriptor))
     type-descriptor))

  (define (thrift:resolve-type type-reference . default)
    (cond ((thrift:type-reference-descriptor type-reference)
	   (thrift:type-reference-descriptor type-reference))
	  ((not (thrift:type-reference-location type-reference))
	   (or (hashtable-ref primitive-types
			      (thrift:type-reference-name type-reference)
			      #f)
	       (if (null? default)
		   (raise (condition
			   (make-assertion-violation)
			   (make-message-condition
			    (string-append "Unknown primitive type " 
					   (thrift:type-reference-name 
					    type-reference)))))
		   (car default))))
	  ((hashtable-contains? types type-reference)
	   (hashtable-ref types type-reference #f))
	  ((null? default)
	   (raise (condition
		   (make-assertion-violation)
		   (make-message-condition
		    (string-append "Unknown type " 
				   (thrift:type-reference-name 
				    type-reference))))))
	  (else (car default))))

  (define services (make-hashtable type-reference-hash type-reference-equiv?))

  (define (thrift:register-service! service-descriptor)
    (hashtable-set! 
     services
     (thrift:make-type-reference 
      (thrift:service-descriptor-name service-descriptor)
      (thrift:service-descriptor-location service-descriptor))
     service-descriptor))

  (define (thrift:resolve-service type-reference)
    (cond ((thrift:type-reference-descriptor type-reference)
	   (thrift:type-reference-descriptor type-reference))
	  ((hashtable-contains? services type-reference)
	   (hashtable-ref services type-reference #f))
	  (else (raise (condition
			(make-assertion-violation)
			(make-message-condition
			 (string-append "Unknown service " 
					(thrift:type-reference-name 
					 type-reference))))))))

  (define (make-enum-predicate values)
    (define syms 
      (map (lambda (value) 
	     (string->symbol (thrift:enum-value-descriptor-name value)))
	   values))

    (lambda (sym) (memq sym syms)))

  (define (make-struct-predicate name fields) 
    (lambda (obj) (thrift:struct? obj)))

  (define (make-exception-predicate name fields)
    (lambda (obj) (thrift:exception? obj)))

  (define (thrift:struct-builder-build b)
    (define (clone-field field)
      (if (thrift:field-has-value? field)
	  (thrift:make-field (thrift:field-field-descriptor field) 
			     (thrift:field-value field))
	  (thrift:make-field (thrift:field-field-descriptor field))))
      
    (define (ensure-required f)
      (let ((fd (thrift:field-field-descriptor f)))
	(if (and (thrift:field-descriptor-required? fd)
		 (not (thrift:field-has-value? f)))
	    (raise (condition 
		    (make-assertion-violation)
		    (make-message-condition 
		     (string-append "Field " 
				    (thrift:field-descriptor-name fd) 
				    " is required.")))))))

    (let* ((type-descriptor (thrift:struct-builder-type-descriptor b))
	   (rtd (thrift:struct-field-type-descriptor-record-type
		 type-descriptor))
	   (ctor (record-constructor
		  (make-record-constructor-descriptor rtd #f #f)))
	   (fields (thrift:struct-builder-fields b)))

      (if (thrift:struct-field-type-descriptor-union? type-descriptor)
	  (let ((fields-with-value (filter thrift:field-has-value? fields)))
	    (if (not (eqv? (length fields-with-value) 1))
		(raise (condition
			(thrift:make-condition)
			(make-assertion-violation)
			(make-message-condition
			 "Exactly one field must be set in union.")))))
			
	  (for-each ensure-required fields))

      (let ((cfs (map clone-field fields)))
	(apply ctor 
	       (cons (thrift:struct-builder-type-descriptor b)		   
		     (cons cfs (map thrift:field-value cfs)))))))

  (define (thrift:struct-builder-field struct-builder index)
    (find (lambda (x)
	    (eqv? (thrift:field-descriptor-index 
		   (thrift:field-field-descriptor x)) 
		  index))
	  (thrift:struct-builder-fields struct-builder)))

  (define (thrift:struct-field struct index)
    (find (lambda (x)
	    (eqv? (thrift:field-descriptor-index 
		   (thrift:field-field-descriptor x)) 
		  index))
	  (thrift:struct-fields struct)))

  (define (thrift:set-field-value! field value)
    (let* ((field-descriptor (thrift:field-field-descriptor field))
	   (type-descriptor 
	    (thrift:resolve-type 
	     (thrift:field-descriptor-type field-descriptor)))
	   (predicate (thrift:field-type-descriptor-predicate 
		       type-descriptor)))
      (if (not (predicate value)) 
	  (raise (condition 
		  (make-assertion-violation)
		  (make-message-condition
		   (string-append
		    "Wrong type for field " 
		    (thrift:field-descriptor-name field-descriptor))))))

      (thrift:set-field-value-internal! field value)
      (thrift:set-field-has-value! field #t)))

  (define (thrift:clear-field! field)
    (let ((field-descriptor (thrift:field-field-descriptor field)))
      (thrift:set-field-has-value! field #f)
      (thrift:set-field-value-internal!
       field (thrift:field-descriptor-default field-descriptor))))

  (define (byte? obj)
    (and (integer? obj) (>= obj -128) (<= obj 127)))
  (define (i16? obj) 
    (and (integer? obj) (>= obj -32768) (<= obj 32767)))
  (define (i32? obj) 
    (and (integer? obj) (>= obj -2147483648) (<= obj 2147483647)))
  (define (i64? obj)
    (and (integer? obj) 
	 (>= obj -9223372036854775808) 
	 (<= obj 9223372036854775807)))

  (define (i32-hash value) value)
  (define (i16-hash value) value)
  (define (i64-hash value)
    (let ((bv (make-bytevector 8)))
      (bytevector-sint-set! bv 0 value (endianness big) 8)
      (bitwise-xor (bytevector-uint-ref bv 0 (endianness big) 4)
		   (bytevector-uint-ref bv 4 (endianness big) 4))))
    
  (define (byte-hash value) value)

  (define (binary-hash bv)
    (let ((len (bytevector-length bv)))
      (let loop ((hashcode 1) (u8s (bytevector->u8-list bv)))
	(if (null? u8s)
	    hashcode
	    (loop (+ (* hashcode 31) (byte-hash (car u8s))) (cdr u8s))))))

  (define (bool-hash value) (if value 1231 1237))

  (define (double-hash value)
    (let ((bv (make-bytevector 8)))
      (bytevector-ieee-double-set! bv 0 value (endianness big))
      (bitwise-xor (bytevector-uint-ref bv 0 (endianness big) 4)
		   (bytevector-uint-ref bv 4 (endianness big) 4))))


  (define (struct-hash value) 0)

  (define (struct-equal? s1 s2) #f)

  (define (make-map-hash key-type value-type)
    (define key-hash-function (thrift:type->hash-function key-type))
    (define value-hash-function (thrift:type->hash-function value-type))

    (lambda (map)
      (let-values (((keys values) (hashtable-entries map)))
	(let loop ((hashcode 0) (i (hashtable-size map)))
	  (if (eqv? i 0)
	      hashcode
	      (loop (+ hashcode
		       (bitwise-xor (key-hash-function (vector-ref keys i))
				    (value-hash-function 
				     (vector-ref values i))))
		    (- i 1)))))))
  
  (define (make-map-equal? key-type value-type)
    (define value-equiv (thrift:type->equivalence-function value-type))

    (lambda (map1 map2)
      (let ((len (hashtable-size map1)))
	(and (eqv? len (hashtable-size map2))
	     (let-values (((keys1 values1) (hashtable-entries map1)))
	       (let loop ((i len))
		 (or (eqv? i 0)
		     (let ((k1 (vector-ref keys1 i)))
		     (and (hashtable-contains? map2 k1)
			  (value-equiv (vector-ref values1 i)
				       (hashtable-ref map2 k1 #f))
			  (loop (- i 1)))))))))))

  (define (make-set-hash type) 
    (define hash-function (thrift:type->hash-function type))
    
    (lambda (set)
      (let loop ((hashcode 0) (set set))
	(if (null? set)
	    hashcode
	    (loop (+ hashcode (hash-function (car set))) 
		  (cdr set))))))

  (define (make-set-equal? type) 
    (define equiv (thrift:type->equivalence-function type))
    (lambda (set1 set2) (lset= equiv set1 set2)))

  (define (make-list-hash type) 
    (define hash-function (thrift:type->hash-function type))

    (lambda (list)
      (let ((len (vector-length list)))
	(let loop ((hashcode 1) (i 0))
	  (if (eqv? i len)
	      hashcode
	      (loop (+ (* hashcode 31) (hash-function (vector-ref list i)))
		    (+ i 1)))))))

  (define (make-list-equal? type) 
    (define equiv (thrift:type->equivalence-function type))

    (lambda (list1 list2)
      (let ((len (vector-length list1)))
	(and (eqv? len (vector-length list2))
	     (let loop ((i len))
	       (or (eqv? i 0)
		   (and (equiv (vector-ref list1 i) (vector-ref list2 i))
			(loop (- i 1)))))))))
  
  (define thrift:field-type-void
    (thrift:make-field-type-descriptor
     "void" #f (thrift:wire-type void) (lambda (obj) #f) 
     (lambda (v) (raise (make-assertion-violation))) (lambda (o1 o2) #f) #f))
 
  (define thrift:field-type-double 
    (thrift:make-field-type-descriptor 
     "double" #f (thrift:wire-type double) real? double-hash eqv? 0))

  (define thrift:field-type-i16 
    (thrift:make-field-type-descriptor 
     "i16" #f (thrift:wire-type i16) i16? i16-hash eqv? 0))

  (define thrift:field-type-i32 
    (thrift:make-field-type-descriptor 
     "i32" #f (thrift:wire-type i32) i32? i32-hash eqv? 0))

  (define thrift:field-type-i64 
    (thrift:make-field-type-descriptor 
     "i64" #f (thrift:wire-type i64) i64? i64-hash eqv? 0))

  (define thrift:field-type-bool
    (thrift:make-field-type-descriptor 
     "bool" #f (thrift:wire-type bool) boolean? bool-hash eqv? #f))

  (define thrift:field-type-string
    (thrift:make-field-type-descriptor 
     "string" #f (thrift:wire-type string) string? string-hash equal? ""))

  (define thrift:field-type-byte
    (thrift:make-field-type-descriptor 
     "byte" #f (thrift:wire-type byte) byte? byte-hash eqv? #\null))

  (define thrift:field-type-binary
    (thrift:make-field-type-descriptor 
     "binary" #f (thrift:wire-type string) bytevector? binary-hash bytevector=?
     (make-bytevector 0)))

  (define thrift:field-type-list-prototype
    (thrift:make-field-type-descriptor 
     "list" #f (thrift:wire-type list) vector? #f #f (make-vector 0)))
  
  (define thrift:field-type-set-prototype
    (thrift:make-field-type-descriptor 
     "set" #f (thrift:wire-type set) list? #f #f '()))

  (define thrift:field-type-map-prototype
    (thrift:make-field-type-descriptor 
     "map" #f (thrift:wire-type map) hashtable? #f #f (make-eq-hashtable)))

  (define primitive-types 
    (let ((ht (make-hashtable string-hash equal?)))
      (for-each 
       (lambda (descriptor)
	 (hashtable-set! 
	  ht (thrift:field-type-descriptor-name descriptor) descriptor))
       (list thrift:field-type-void
	     thrift:field-type-double
	     thrift:field-type-i16
	     thrift:field-type-i32
	     thrift:field-type-i64
	     thrift:field-type-bool
	     thrift:field-type-byte
	     thrift:field-type-string
	     thrift:field-type-binary))
      ht))

  (define (thrift:type->equivalence-function type-reference)
    (define type (thrift:resolve-type type-reference))

    (or type (raise (make-assertion-violation)))
    (case (thrift:field-type-descriptor-wire-type type)
      ((enum) eq?)
      ((bool byte i16 i32 i64 double) eqv?)
      ((string) equal?)
      ((struct) struct-equal?)

      ((map) 
       (let* ((params 
	       (thrift:parameterized-field-type-descriptor-parameters type))
	      (key-type (car params))
	      (value-type (cadr params)))
	 (make-map-equal? key-type value-type)))

      ((set)
       (make-set-equal? 
	(car (thrift:parameterized-field-type-descriptor-parameters type))))

      ((list)
       (make-list-equal? 
	(car (thrift:parameterized-field-type-descriptor-parameters type))))

      (else (raise (make-assertion-violation)))))

  (define (thrift:type->hash-function type-reference)
    (define type (thrift:resolve-type type-reference))

    (or type (raise (make-assertion-violation)))
    (case (thrift:field-type-descriptor-wire-type type)
      ((bool) bool-hash)
      ((byte) byte-hash)
      ((i16) i16-hash)
      ((i32) i32-hash)
      ((i64) i64-hash)
      ((double) double-hash)
      ((string) string-hash)
      ((struct) struct-hash)

      ((map) 
       (let* ((params 
	       (thrift:parameterized-field-type-descriptor-parameters type))
	      (key-type (car params))
	      (value-type (cadr params)))
	 (make-map-hash key-type value-type)))

      ((set)
       (make-set-hash 
	(car (thrift:parameterized-field-type-descriptor-parameters type))))

      ((list) 
       (make-list-hash
	(car (thrift:parameterized-field-type-descriptor-parameters type))))

      ((enum) symbol-hash)
      (else (raise (make-assertion-violation)))))
)
